home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 501-525 / disk_525 / siod / siod.scm < prev    next >
Lisp/Scheme  |  1992-05-06  |  6KB  |  245 lines
  1. ;; SIOD: Scheme In One Defun                                    -*-mode:lisp-*-
  2. ;;
  3. ;; *                        COPYRIGHT (c) 1989 BY                            *
  4. ;; *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.      *
  5. ;; *        See the source file SLIB.C for more information.                 *
  6.  
  7. ;;  Optional Runtime Library for Release 2.4
  8.  
  9. (define list (lambda n n))
  10.  
  11. (define (sublis l exp)
  12.   (if (cons? exp)
  13.       (cons (sublis l (car exp))
  14.         (sublis l (cdr exp)))
  15.       (let ((cell (assq exp l)))
  16.     (if cell (cdr cell) exp))))
  17.  
  18. (define (caar x) (car (car x)))
  19. (define (cadr x) (car (cdr x)))
  20. (define (cdar x) (cdr (car x)))
  21. (define (cddr x) (cdr (cdr x)))
  22.  
  23. (define (caddr x) (car (cdr (cdr x))))
  24. (define (cdddr x) (cdr (cdr (cdr x))))
  25.  
  26. (define consp pair?)
  27.  
  28. (define (replace before after)
  29.   (set-car! before (car after))
  30.   (set-cdr! before (cdr after))
  31.   after)
  32.  
  33. (define (prognify forms)
  34.   (if (null? (cdr forms))
  35.       (car forms)
  36.     (cons 'begin forms)))
  37.  
  38. (define (defmac-macro form)
  39.   (let ((sname (car (cadr form)))
  40.     (argl (cdr (cadr form)))
  41.     (fname nil)
  42.     (body (prognify (cddr form))))
  43.     (set! fname (symbolconc sname '-macro))
  44.     (list 'begin
  45.       (list 'define (cons fname argl)
  46.         (list 'replace (car argl) body))
  47.       (list 'define sname (list 'quote fname)))))
  48.  
  49. (define defmac 'defmac-macro)
  50.  
  51. (defmac (push form)
  52.   (list 'set! (caddr form)
  53.     (list 'cons (cadr form) (caddr form))))
  54.  
  55. (defmac (pop form)
  56.   (list 'let (list (list 'tmp (cadr form)))
  57.     (list 'set! (cadr form) '(cdr tmp))
  58.     '(car tmp)))
  59.  
  60. (defmac (defvar form)
  61.   (list 'or
  62.     (list 'symbol-bound? (list 'quote (cadr form)))
  63.     (list 'define (cadr form) (caddr form))))
  64.  
  65. (defmac (defun form)
  66.   (cons 'define
  67.     (cons (cons (cadr form) (caddr form))
  68.           (cdddr form))))
  69.  
  70. (defmac (setq form)
  71.   (let ((l (cdr form))
  72.     (result nil))
  73.     (define (loop)
  74.       (if l
  75.       (begin (push (list 'set! (car l) (cadr l)) result)
  76.          (set! l (cddr l))
  77.          (loop))))
  78.     (loop)
  79.     (prognify (reverse result))))
  80.   
  81.   
  82. (define progn begin)
  83.  
  84. (define the-empty-stream ())
  85.  
  86. (define empty-stream? null?)
  87.  
  88. (define (*cons-stream head tail-future)
  89.   (list head () () tail-future))
  90.  
  91. (define head car)
  92.  
  93. (define (tail x)
  94.   (if (car (cdr x))
  95.       (car (cdr (cdr x)))
  96.       (let ((value ((car (cdr (cdr (cdr x)))))))
  97.     (set-car! (cdr x) t)
  98.     (set-car! (cdr (cdr x)) value))))
  99.  
  100. (defmac (cons-stream form)
  101.   (list '*cons-stream
  102.     (cadr form)
  103.     (list 'lambda () (caddr form))))
  104.  
  105. (define (enumerate-interval low high)
  106.   (if (> low high)
  107.       the-empty-stream
  108.       (cons-stream low (enumerate-interval (+ low 1) high))))
  109.  
  110. (define (print-stream-elements x)
  111.   (if (empty-stream? x)
  112.       ()
  113.       (begin (print (head x))
  114.          (print-stream-elements (tail x)))))
  115.  
  116. (define (sum-stream-elements x)
  117.   (define (loop acc x)
  118.     (if (empty-stream? x)
  119.     acc
  120.       (loop (+ (head x) acc) (tail x))))
  121.   (loop 0 x))
  122.  
  123. (define (standard-fib x)
  124.   (if (< x 2)
  125.       x
  126.       (+ (standard-fib (- x 1))
  127.      (standard-fib (- x 2)))))
  128.  
  129. (define (make-list n)
  130.   (define l ())
  131.   (define j 0)
  132.   (define (accumulate-list)
  133.     (if (< j n)
  134.     (begin (setq l (cons () l))
  135.            (setq j (+ j 1))
  136.            (accumulate-list))))
  137.   (accumulate-list)
  138.   l)
  139.  
  140.   
  141. (define (call-with-current-continuation fcn)
  142.   (let ((tag (cons nil nil)))
  143.     (*catch tag
  144.         (fcn (lambda (value)
  145.            (*throw tag value))))))
  146.  
  147.  
  148. (defun atom (x)
  149.   (not (consp x)))
  150.  
  151. (define eq eq?)
  152.  
  153. (defmac (cond form)
  154.   (cond-convert (cdr form)))
  155.  
  156. (define null null?)
  157.  
  158. (defun cond-convert (l)
  159.   (if (null l)
  160.       ()
  161.     (if (null (cdar l))
  162.     (if (null (cdr l))
  163.         (caar l)
  164.       (let ((rest (cond-convert (cdr l))))
  165.         (if (and (consp rest) (eq (car rest) 'or))
  166.         (cons 'or (cons (caar l) (cdr rest)))
  167.           (list 'or (caar l) rest))))
  168.       (if (or (eq (caar l) 't)
  169.           (and (consp (caar l)) (eq (car (caar l)) 'quote)))
  170.       (prognify (cdar l))
  171.     (list 'if
  172.           (caar l)
  173.           (prognify (cdar l))
  174.           (cond-convert (cdr l)))))))
  175.  
  176. (defmac (+internal-comma form)
  177.   (error 'comma-not-inside-backquote))
  178.  
  179. (define +internal-comma-atsign +internal-comma)
  180. (define +internal-comma-dot +internal-comma)
  181.  
  182. (defmac (+internal-backquote form)
  183.   (backquotify (cdr form)))
  184.  
  185. (defun backquotify (x)
  186.   (let (a d aa ad dqp)
  187.     (cond ((atom x) (list 'quote x))
  188.       ((eq (car x) '+internal-comma) (cdr x))
  189.       ((or (atom (car x))
  190.            (not (or (eq (caar x) '+internal-comma-atsign)
  191.             (eq (caar x) '+internal-comma-dot))))
  192.        (setq a (backquotify (car x)) d (backquotify (cdr x))
  193.          ad (atom d) aa (atom a)
  194.          dqp (and (not ad) (eq (car d) 'quote)))
  195.        (cond ((and dqp (not (atom a)) (eq (car a) 'quote))
  196.           (list 'quote (cons (cadr a) (cadr d))))
  197.          ((and dqp (null (cadr d)))
  198.           (list 'list a))
  199.          ((and (not ad) (eq (car d) 'list))
  200.           (cons 'list (cons a (cdr d))))
  201.          (t (list 'cons a d))))
  202.       ((eq (caar x) '+internal-comma-atsign)
  203.        (list 'append (cdar x) (backquotify (cdr x))))
  204.       ((eq (caar x) '+internal-comma-dot)
  205.        (list 'nconc (cdar x)(backquotify (cdr x)))))))
  206.  
  207.  
  208. (defun append n
  209.   (appendl n))
  210.  
  211. (defun appendl (l)
  212.   (cond ((null l) nil)
  213.     ((null (cdr l)) (car l))
  214.     ((null (cddr l))
  215.      (append2 (car l) (cadr l)))
  216.     ('else
  217.      (append2 (car l) (appendl (cdr l))))))
  218.  
  219. (defun append2 (a b)
  220.   (if (null a)
  221.       b
  222.     (cons (car a) (append2 (cdr a) b))))
  223.  
  224. (defun rplacd (a b)
  225.   (set-cdr! a b)
  226.   a)
  227.  
  228. (defun nconc (a b)
  229.   (if (null a)
  230.       b
  231.     (rplacd (last a) b)))
  232.  
  233.  
  234. (defun last (a)
  235.   (cond ((null a) (error'null-arg-to-last))
  236.     ((null (cdr a)) a)
  237.     ((last (cdr a)))))
  238.  
  239. (define sfib
  240.   (eval `(lambda (x)
  241.        (,if (,< x 2)
  242.            x
  243.          (,+ (sfib (,- x 1))
  244.          (sfib (,- x 2)))))))
  245.